Tech Arsenal 2/Tech Arsenal 2 (Arsenal Computer).iso/clipper/s93bsp.exe/S87/HOUSE00.PRG

Text File | 1993-10-26 | 5.3 KB | 232 lines

procedure HOUSEMAIN
*       H O U S E 0 0
*       Main controlling routine for Housekeeping
private HSCOM, OLDMLIN, RTITLE, RCHOIX
QBCHOICE = 1
do while .t.
*    Last change:  MIB  26 Oct 93    5:51 pm

    close database
    do QBLAYOUT with "Housekeeping"
    do QBBOX with 40
    do QBMENU with "HOUSEKE",40
    RTITLE = QBPROC
    RCHOIX = QBCHOICE
    do case
    case RCHOIX=0 .or. RCHOIX=5
        exit
    case RCHOIX=1
        do QBLAYOUT with RTITLE
        do CTEDIT with 5, 19, 15, 1
    case RCHOIX=2
        do QBLAYOUT with RTITLE
        do QBBOX with 40
    case RCHOIX=3
        do QBLAYOUT with RTITLE
        do QBBOX with 40
        do BODARCH
    case RCHOIX=4
        do QBLAYOUT with RTITLE
        do QBBOX with 40
        do BODREST
    endcase
    QBCHOICE = RCHOIX
enddo
set softseek off
return

*******************************************************************

procedure BODARCH
*   B O D A R C H . P R G
*  Program to archive Invoices
private STATUS, D1, D2
status = 0
store ctod("") to D1,D2

select 0
use PARTS index PARTINV alias PARTS
select 0
use INVOICE index INVDATE,INVNUM, INVCUST alias INVOICE

* Method: Create structure on Disc a:
adate = date()

@ 5, 26 SAY " First date: "
@ 7, 26 say "Second date: "
do QB2DATES with "Input Start and Finish dates",5,39,D1,7,39,D2

set softseek on
seek dtos(D1)
IF eof()
    DO qbmess WITH "No Invoices to be archived",colflash,5
    RETURN
ENDIF

IF QBYESNO("OK to Continue?")="N" .or. GETOUT
    CLOSE DATABASE
    RETURN
ENDIF

DO qbmess WITH "Place a formatted floppy in drive A",colhead,0
if .not. DRIVEOK()
    GETOUT = .f.
    return
endif
DO qbmess WITH "Selecting Invoices",colflash,0


DO qbmess WITH "Archiving Invoices and Parts to Floppy",colflash,0

* Create Files on Floppy
SELECT invoice
copy structure to A:invoice
SELECT PARTS
copy structure to A:PARTS
select 0
use A:PARTS alias APARTS
select 0
use a:INVOICE  alias ANVOICE

go top
select INVOICE
set softseek on                    && Invoices
seek dtos(D1)
DO WHILE INVOICE->DATEINV<=D2 .and. ! eof()
    getrec()                                && Get the current record in the database
    select ANVOICE
    putrec()                                && Put it in the other
    MINVNO = ANVOICE->INVNO                 && Get a number from A drive

    set softseek off                        && Part by Invoice #
    select PARTS
    seek str(MINVNO,5)                      && Find in main file
    do while  .not. eof() .and. MINVNO=PARTS->INVNO
        getrec()
        select APARTS
        putrec()
        select PARTS
        do QBWIPE                           && Erase
        seek str(MINVNO,5)                  && Find in main file
    enddo

    set softseek on                         && Erase Invoice, Get next
    select INVOICE
    do QBWIPE
    seek dtos(D1)
ENDDO

DO qbclmess
CLOSE DATABASE
DO qbmess WITH "Remove floppy from drive A: and label it",colhead,0
WAIT
set softseek off

do QBCLMESS
RETURN

*******************************************************************
function GETREC
private NumFlds, T, I
NumFlds = fcount()
public DBREC[NumFlds], DBNAME[NumFlds]

afields(DBNAME)
for I=1 to NumFlds
    T = DBNAME[I]
    DBREC[I] = &T
next

blimempak(-1)

return .t.

*******************************************************************
function PUTREC
private NumFlds, T, I
NumFlds = fcount()

append blank
afields(DBNAME)
for I=1 to NumFlds
    T = DBNAME[I]
    replace &T with DBREC[I]
next

blimempak(-1)

return .t.

*******************************************************************

procedure BODREST
*   B O D R E S T
private STATUS
status = 0
select 0
use INVOICE index INVNUM, INVDATE, INVCUST
select 0
use PARTS index PARTINV

@ 5, 26 SAY "Restoring Invoices"

IF QBYESNO("OK to Continue?")="N"
    CLOSE DATABASE
    RETURN
ENDIF

DO WHILE .t.
    DO qbmess WITH "Place the Archive floppy in drive A",colhead,0
    if .not. DRIVEOK()
        GETOUT = .f.
        return
    endif
    IF  file("a:invoice.dbf") .and. file("a:parts.dbf")
        do QBMESS with "Appending Invoices from Floppy",colhead,0
        select INVOICE
        append from a:INVOICE
        select PARTS
        append from a:PARTS
        exit
    ELSE
        DO qbmess WITH "Floppy does not contain correct files - try again",;
        colflash,5
        IF QBYESNO("OK to try again?")="N"
            CLOSE DATABASE
            RETURN
        ENDIF
    ENDIF
ENDDO
do QBMESS with "Reindexing Invoices",colhead,0
select INVOICE
index on str(INVNO,5) to INVNUM
index on dtos(DATEOUT) + CUSTTYPE to INVDATE
index on CUSTTYPE + dtos(DATEOUT) to INVCUST
index on upper(OWNNAME) to INVNAME

select parts
index on str(INVNO,5)+str(PLINENO,2) to PARTINV

DO qbmess WITH "Remove floppy from drive A: ",colhead,0
WAIT

CLOSE DATABASE

RETURN

*******************************************************************


*******************************************************************
function DRIVEOK
GETOUT = .f.
do while .not. isdrive("A")
    ACTION = QBPROMPT("Continue|Quit|","Floppy is not ready - correct and continue or Quit",1)
    if ACTION<>1
        GETOUT = .t.
        exit
    endif
enddo

return .not. GETOUT